perm filename WLDMOD.BAK[AL,HE] blob
sn#390160 filedate 1978-10-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 EXTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR VINTEGER OP
C00009 ENDMK
C⊗;
EXTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
RPTR(CALCULATOR) C);
EXTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
RPTR(CHANGER) C);
EXTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RANY F1,F2;REFERENCE RCELL GPHCODE);
EXTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RANY F1,F2,BV;REXPR AE;RVAR RGF;
REFERENCE RCELL GPHCODE);
INTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
RPTR(CALCULATOR) C);
BEGIN
RPTR(GASSIGN) GA;
GA←NEW_RECORD(GASSIGN);
GASSIGN:VAR[GA]←V;
GASSIGN:OP[GA]←OP;
GASSIGN:CLC[GA]←C;
RETURN(GA);
END;
INTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
RPTR(CHANGER) C);
BEGIN
RPTR(ALSODO) ADO;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←V;
ALSODO:OP[ADO]←OP;
ALSODO:CHG[ADO]←C;
RETURN(ADO);
END;
! do_affix, do_affix_stmnt, do_unfix;
INTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RANY F1,F2;REFERENCE RCELL GPHCODE);
BEGIN
RPTR(EXPRN,VARIABLE) BYEX;
RPTR(AFXDATA) AD;
RVAR RGF;
IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,OW);
IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,OW);
IF LPMATCH(OW,\(AFFIXED,$ F1,$ F2,BIND BYEX,BIND RGF) ) THEN
BEGIN
DENYF(OW,_FACT_);
AD←AFXDGET(F1,F2,BYEX,FALSE);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:T[AD]=BYEX THEN
BYEX←AFXDATA:INVT[AD]
ELSE
BYEX←AFXDATA:T[AD];
LPDENY(OW,\(AFFIXED,$ F2,$ F1,BYEX,RIGIDLY) );
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCALC(OW,F2,AFXDATA:C2[AD]);
CONSON(NEW_GASSIGN(F2,2,AFXDATA:C2[AD]),GPHCODE);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCHG(OW,F1,AFXDATA:CHG[AD]);
! should kill old one!; CONSON(NEW_ALSODO(F1,2,AFXDATA:CHG[AD]),GPHCODE);
END;
CONSON(NEW_GASSIGN(F1,2,AFXDATA:C1[AD]),GPHCODE);
END;
END;
INTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RANY F1,F2,BV;REXPR AE;RVAR RGF;
REFERENCE RCELL GPHCODE);
BEGIN
RANY ASTN;
RPTR(TRANS) T;
RPTR(AFXDATA) AD;
RPTR(VARIABLE) BVV;
RPTR(BLOCK) BID;
RPTR(ASSIGNMENT) ASG;
IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,OW);
IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,OW);
IF RECTYPE(BV) = LOC(EXPRN) THEN BV ← ARRAYREF(BV,OW);
DO_UNFIX(OW,F1,F2,GPHCODE);
AD←AFXDGET(F1,F2,BV,TRUE);
IF AE=NULL_RECORD THEN
AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
! FTOF(F2,F1);
VCHANGE(BV,EVALEXPR(AE,OW),OW);
BID←VARIABLE:BLK[AFXDATA:YOUNGEST[AD]];
LPASRT(OW,\(AFFIXED,$ F1, $ F2, $ BV, $ RGF));
IF AFXDATA:C1[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:C1[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F2,BV) ),BID));
END;
CONSON(NEW_GASSIGN(F1,1,AFXDATA:C1[AD]),GPHCODE);
ADDCALC(OW,F1,AFXDATA:C1[AD]);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:INVT[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:INVT[AD]←NEW_EXPRN(TRANS_DTYPE,
TINVRT_OP,CONS(BV,NULL_RECORD));
AFXDATA:C2[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F1,AFXDATA:INVT[AD])),BID));
END;
CONSON(NEW_GASSIGN(F2,1,AFXDATA:C2[AD]),GPHCODE);
LPASRT(OW,\(AFFIXED,$ F2,$ F1,$ AFXDATA:INVT[AD], RIGIDLY));
ADDCALC(OW,F2,AFXDATA:C2[AD]);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
IF AFXDATA:CHG[AD]=NULL_RECORD THEN
BEGIN
RVAR FF2; ! to get around a SAIL lossage;
RPTR(ASSIGNMENT) ASG;
FF2←F2;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(FF2,NULL_RECORD)),
VNEWTRANS) );
AFXDATA:CHG[AD]←ASGLBL(NEW_LBL(ANY,CHGLAB_DTYPE,BID),
BLDCHG(STMAKE(ASG),BID));
END;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←F1;ALSODO:OP[ADO]←1;
ALSODO:CHG[ADO]←AFXDATA:CHG[AD];
ADDCHG(OW,F1,AFXDATA:CHG[AD]);
CONSON(ADO,GPHCODE);
END;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←AE;
CONSON(ASG,GPHCODE);
END;